home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / oodles-of-utils.sea / oodles-of-utils / oou-init.lisp / oou-init.lisp
Encoding:
Text File  |  1992-12-12  |  5.5 KB  |  164 lines  |  [TEXT/CCL2]
  1. ;; -*- package: oou -*-
  2. (provide :oou)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; oou-init.Lisp
  5. ;;
  6. ;; Copyright © 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; load this file before using oodles-of-utils
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14.  
  15. (defpackage :oou
  16.   (:nicknames :oodles-of-utils)
  17.   (:use :common-lisp :ccl)
  18.   (:import-from :ccl
  19.                 :find-field-descriptor
  20.                 :with-cstrs
  21.                 :%put-point
  22.                 :%getport
  23.                 :%clear-block
  24.                 :window-erase-region
  25.                 :*simple-view-clip-region*
  26.                 :color-list
  27.                 :rletz
  28.                 ))
  29.  
  30. (in-package :oou)
  31.  
  32. (export '(oou-dependencies compile-oou))
  33.  
  34. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35.  
  36.  
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ;;;set up logical pathnames
  39.  
  40. (setf (logical-pathname-translations "mcl")
  41.       `((#P"**;*.*" "ccl:**;*.*"))
  42.       
  43.       (logical-pathname-translations "oou-top")
  44.       `((#P"**;" "mcl:oodles-of-utils;**;"))
  45.       
  46.       (logical-pathname-translations "oou-fasl")
  47.       `((#P"**;+*.*" "oou-top:NotInROM;*.*")
  48.         (#P"**;*.*"  "oou-top:oou-fasl;*.*"))
  49.       
  50.       (logical-pathname-translations "oou-mods")
  51.       `((#P"**;*.*" "oou-top:oou-mods;*.*"))
  52.       
  53.       (logical-pathname-translations "oou-patches")
  54.       `((#P"**;*.*" "oou-top:patches;*.*"))
  55.       
  56.       (logical-pathname-translations "oou")
  57.       `((#P"**;*.fasl" "oou-fasl:*.*")
  58.         (#P"**;*.*"    "oou-top:**;*.*")))
  59.  
  60.  
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62. ;; primitive dependency/require facility - should be improved
  63. ;; or maybe switched over to defsystem
  64.  
  65. (defvar *oou-modules* nil)
  66.  
  67. ;used to "fix" return paths of directory to work with meta-.
  68. (defun oou-enough-namestring (path)
  69.   (let ((enough (enough-namestring path (translate-logical-pathname "oou:"))))
  70.     (logical-pathname 
  71.      (if (char= #\: (char enough 0))
  72.        (concatenate 'string "oou" (substitute #\; #\: enough :start 1))
  73.        (concatenate 'string "oou:" enough)))))
  74.  
  75. (defun oou-pick-load-file (name)
  76.   (let ((mods (merge-pathnames name "oou-mods:*.lisp"))
  77.         (fasl (merge-pathnames name "oou-fasl:*.fasl"))
  78.         (lisp (first (directory (merge-pathnames name "oou:**;*.lisp")))))
  79.     (cond
  80.      ((probe-file mods) (merge-pathnames name "oou-mods:*"))
  81.      ((null (probe-file fasl)) (oou-enough-namestring  lisp))
  82.      ((null (probe-file lisp)) (oou-enough-namestring  fasl))
  83.      ((> (file-write-date lisp) (file-write-date fasl)) (oou-enough-namestring  lisp))
  84.      (fasl))))
  85.  
  86. (defun oou-require (module)
  87.   (let ((module-string (etypecase module
  88.                          (symbol (symbol-name module))
  89.                          (string module))))
  90.     (unless (find module-string *oou-modules* :test #'string-equal)
  91.       (let ((path (oou-pick-load-file module-string))
  92.             (loaded-p nil))
  93.         (unless path (error "couldn't find file named ~a in oodles-of-utils" module-string))
  94.         (unwind-protect
  95.           (progn
  96.             (pushnew module-string *oou-modules* :test #'string-equal)
  97.             (load path)
  98.             (setf loaded-p t))
  99.           (unless loaded-p
  100.             (setf *oou-modules* (delete module-string *oou-modules* :test #'string-equal))))))))
  101.  
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. ;; primitive compilation facility
  104.  
  105. (defparameter *oou-no-compile-paths* `("**;work-in-progress;**;"
  106.                                        "**;boondoggles;**;"
  107.                                        "**;examples;**;"
  108.                                        "**;oou-fasl;**;"
  109.                                        "**;oou-mods;**;"
  110.                                        "**;*-example.lisp"
  111.                                        "**;*-test.lisp"
  112.                                        "**;*-scrap.lisp"
  113.                                        "oou-init.lisp"
  114.                                        ))
  115.  
  116. (defun oou-source-files ()
  117.   (mapcar #'oou-enough-namestring
  118.           (directory
  119.            "oou:**;*.lisp"
  120.            :test #'(lambda (file) (not (find file *oou-no-compile-paths* :test #'pathname-match-p))))))
  121.  
  122. (defun compile-oou ()
  123.   (dolist (lisp-path (oou-source-files))
  124.     (let ((fasl-path (merge-pathnames  "oou-fasl:.fasl" lisp-path)))
  125.       (when (or (null (probe-file fasl-path))
  126.                 (< (file-write-date fasl-path) (file-write-date lisp-path)))
  127.         (format t "~%;Compiling ~s~%" lisp-path)
  128.         (compile-file lisp-path :output-file fasl-path :verbose *compile-verbose* :print *compile-print*)))))
  129.  
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131. ;;
  132.  
  133. (defun load-oou ()
  134.   (dolist (file (oou-source-files))
  135.     (load (oou-pick-load-file (pathname-name file)))))
  136.  
  137.  
  138. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  139. ;; oou's version of provide and require
  140.  
  141. (defmacro oou-provide (module) (declare (ignore module)) (values))
  142.  
  143. (defmacro oou-dependencies (&rest modules)
  144.   `(eval-when (:compile-toplevel :load-toplevel :execute)
  145.      ,@(mapcar #'(lambda (m) `(oou-require ,m)) modules)))
  146.  
  147.  
  148. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  149. ;;executed forms
  150.  
  151. (use-package :oou :cl-user) ;cl-user uses oou
  152.  
  153. (push #4P"oou:NotInRom;" *module-search-path*)
  154.  
  155. (oou-require :patches)
  156.  
  157.  
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159.  
  160. #|
  161. (compile-oou)
  162.  
  163. (load-oou)
  164. |#